{---------------------------------------------
  Author: Yun
  DateTime:2014.03.14
---------------------------------------------}
unit NewMessageBox;

interface

uses
  Classes, Windows, Controls, Forms, Dialogs, StdCtrls, SysUtils, Graphics,
  Math, ExtCtrls, RzBckgnd;

type
  //MessageBox类型
  TMsgBoxType = (btSuccess, btWarning, btError, btInformation, btQuestion, btCustom);
  //Buttons集合
  TNewMsgBoxBtn  = (btnYes, btnNo, btnOk, btnCancel, btnAbort, btnRetry, btnIgnore,
    btnAll, btnNoToAll, btnYesToAll, btnHelp, btnForceClose, btnContinue, btnExit);
  TNewMsgBoxBtns = set of TNewMsgBoxBtn;

const
  mbOk  = [btnOk];
  mbExit= [btnExit];
  mbYesNo = [btnYes, btnNo];
  mbYesNoCancel = [btnYes, btnNo, btnCancel];
  mbOKCancel = [btnOk, btnCancel];
  mbContinueExit = [btnContinue, btnExit];
  mbAbortIgnore = [btnAbort, btnIgnore];
  mbAbortRetryIgnore = [btnAbort, btnRetry, btnIgnore];

const
  mrForceClose= mrYesToAll   + 1;
  mrContinute = mrForceClose + 1;
  mrExit      = mrContinute  + 1;

  BTN_YES        = mrYes;
  BTN_NO         = mrNo;
  BTN_OK         = mrOk;
  BTN_CANCEL     = mrCancel;
  BTN_ABORT      = mrAbort;
  BTN_RETRY      = mrRetry;
  BTN_IGNORE     = mrIgnore;
  BTN_ALL        = mrAll;
  BTN_NOTOALL    = mrNoToAll;
  BTN_YESTOALL   = mrYesToAll;
  BTN_HELP       = 0;
  BTN_FORCECLOSE = mrForceClose;
  BTN_CONTINUE   = mrContinute;
  BTN_EXIT       = mrExit;

  //创建MessageDialog窗体
  function CreateMessageBox(const Msg: string; BoxType: TMsgBoxType; Buttons: TNewMsgBoxBtns): TForm;
  //输出函数
  function MessageBoxPro(const Msg: string; BoxType: TMsgBoxType; Buttons: TNewMsgBoxBtns): Integer;

implementation

//uses XPMan;

{$R icons.RES}

type
  TMessageBoxForm = class(TForm)
  private
    Message: TLabel;
    Header : TRzSeparator;
    Title  : TLabel;
    PanelCenter : TPanel;
    PanelBottom : TPanel;
    procedure HelpButtonClick(Sender: TObject);
  protected
    procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure WriteToClipBoard(Text: String);
    function GetFormText: String;
  public
    constructor CreateNew(AOwner: TComponent); reintroduce;
  end;
  
//==============================================================================
procedure Beep;
begin
  MessageBeep(0);
end;

constructor TMessageBoxForm.CreateNew(AOwner: TComponent);
var
  NonClientMetrics: TNonClientMetrics;
begin
  inherited CreateNew(AOwner);
  NonClientMetrics.cbSize := sizeof(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
end;

procedure TMessageBoxForm.HelpButtonClick(Sender: TObject);
begin
  Application.HelpContext(HelpContext);
end;

procedure TMessageBoxForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if (Shift = [ssCtrl]) and (Key = Word('C')) then
  begin
    Beep;
    WriteToClipBoard(GetFormText);
  end;
end;

procedure TMessageBoxForm.WriteToClipBoard(Text: String);
var
  Data: THandle;
  DataPtr: Pointer;
begin
  if OpenClipBoard(0) then
  begin
    try
      Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, Length(Text) + 1);
      try
        DataPtr := GlobalLock(Data);
        try
          Move(PChar(Text)^, DataPtr^, Length(Text) + 1);
          EmptyClipBoard;
          SetClipboardData(CF_TEXT, Data);
        finally
          GlobalUnlock(Data);
        end;
      except
        GlobalFree(Data);
        raise;
      end;
    finally
      CloseClipBoard;
    end;
  end
  else
    raise Exception.Create('Cannot open clipboard');
end;

function TMessageBoxForm.GetFormText: String;
var
  DividerLine, ButtonCaptions: string;
  I: integer;
begin
  DividerLine := StringOfChar('-', 27) + sLineBreak;
  for I := 0 to ComponentCount - 1 do
    if Components[I] is TButton then
      ButtonCaptions := ButtonCaptions + TButton(Components[I]).Caption +
        StringOfChar(' ', 3);
  ButtonCaptions := StringReplace(ButtonCaptions,'&','', [rfReplaceAll]);
  Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, sLineBreak,
    DividerLine, Message.Caption, sLineBreak, DividerLine, ButtonCaptions,
    sLineBreak, DividerLine]);
end;
//==============================================================================

var
  IconIDs: array[TMsgBoxType] of string = ('MB_ICONSUCCESS', 'MB_ICONWARNING', 'MB_ICONERROR',
    'MB_ICONINFOMATION', 'MB_ICONQUESTION', '');
  ButtonNames: array[TNewMsgBoxBtn] of string = (
    'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll',
    'YesToAll', 'Help', 'ForceClose', 'Continue', 'Exit');
  ButtonCaptions: array[TNewMsgBoxBtn] of string = (
    '是', '否', '确定', '取消', '终止', '重试', '忽略',
    '全部', '全否', '全是', '帮助', '强制关闭', '继续', '退出');
  ModalResults: array[TNewMsgBoxBtn] of Integer = (
    mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,
    mrYesToAll, 0, mrForceClose, mrContinute, mrExit);

function CreateMessageBox(const Msg: string; BoxType: TMsgBoxType; Buttons: TNewMsgBoxBtns): TForm;
const
  hHeight        = 44;
  imgTop         = 6;
  imgLeft        = 8;
  btnButtonWidth  = 75;
  btnButtonHeight = 25;
  btnButtonSpace  = 4;
  btnButtonMargin = 9;
  lbLeft         = 26;
  lbMessageWidth = 407;
  lbMargin       = 24;
  aLeft          = 48;
  fMinClientWidth= 350;
  pBottomHeight  = 43;
var
  B, DefaultButton, CancelButton: TNewMsgBoxBtn;
  X, ButtonCount: Integer;
  IconID: string;
  TextRect: TRect;
begin
  Result := TMessageBoxForm.CreateNew(Application);
  with Result do
  begin
    //基本属性设置
    Font.Name:= '微软雅黑';
    Font.Size:= 9;
    BiDiMode := Application.BiDiMode;
    BorderStyle := bsDialog;
    Canvas.Font := Font;
    KeyPreview := True;
    OnKeyDown := TMessageBoxForm(Result).CustomKeyDown;

    //动态获取MessageLabel的高度
    SetRect(TextRect, 0, 0, lbMessageWidth, 0);
    DrawText(Canvas.Handle, PChar(Msg), Length(Msg)+1, TextRect,
      DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or
      DrawTextBiDiModeFlagsReadingOnly);

    //取Icon编号
    IconID := IconIDs[BoxType];

    //按钮数
    ButtonCount := 0;
    for B := Low(TNewMsgBoxBtn) to High(TNewMsgBoxBtn) do
      if B in Buttons then Inc(ButtonCount);

    //窗体大小和位置
    if ((TextRect.Right + lbLeft*2) < fMinClientWidth) then
      ClientWidth:= fMinClientWidth
    else
      ClientWidth  := lbMessageWidth + lbLeft*2;
    ClientHeight := hHeight + lbMargin + TextRect.Bottom + lbMargin + pBottomHeight;
    Left := (Screen.Width div 2) - (Width div 2);
    Top  := (Screen.Height div 2) - (Height div 2);

    Caption := '提示';

    //创建顶部RzSeparator
    TMessageBoxForm(Result).Header := TRzSeparator.Create(Result);
    with TMessageBoxForm(Result).Header do
    begin
      Name   := 'Header';
      Parent := Result;
      Height := hHeight;
      Align  := alTop;
      HighlightLocation:= hlUpperLeft;
      HighlightColor:= clWhite;
      Color:= clWhite;
      {case BoxType of
        btSuccess: begin
          HighlightColor:= $00157615;
          Color:= $003F9639;
        end;
        btWarning: begin
          HighlightColor:= $0000B1F2;
          Color:= $0046CCFE;
        end;
        btError: begin
          HighlightColor:= $000001AD;
          Color:= $000001DC;
        end;
        btInformation: begin
          HighlightColor:= $00845D34;
          Color:= $00F3E4DA;
        end;
        btQuestion: begin
          HighlightColor:= $00845D34;
          Color:= $00F3E4DA;
        end;
        btCustom: begin
          HighlightColor:= $00845D34;
          Color:= $00F3E4DA;
        end;
      end;}
    end;

    //Header中的标题
    with TLabel.Create(Result) do
    begin
      Name   := 'TitleLabel';
      Parent := Result;
      Left   := aLeft;
      Top    := 10;
      case BoxType of
        btSuccess    : Caption:= '成功';
        btWarning    : Caption:= '警告';
        btError      : Caption:= '错误';
        btInformation: Caption:= '提示';
        btQuestion   : Caption:= '询问';
        btCustom     :
        begin
         Caption:= '信息';
         Left   := lbLeft;
        end;
      end;
      Font.Color:= clBlack;
      Font.Size:= 13;
      Transparent:= True;
    end;

    //Panel中的图标
    if IconID <> '' then
    with TImage.Create(Result) do
    begin
      Name := 'Image';
      Parent := Result;
      Picture.Icon.Handle := LoadIcon(HInstance, PChar(IconID));
      //AutoSize:= True;
      SetBounds(imgLeft, imgTop, 48 , 48);
    end;

    //按钮区
    TMessageBoxForm(Result).PanelBottom := TPanel.Create(Result);
    with TMessageBoxForm(Result).PanelBottom do
    begin
      Name := 'PanelBottom';
      Parent:= Result;
      Align:= alBottom;
      BevelOuter:= bvNone;
      Caption:= '';
      Height:= pBottomHeight;
    end;

    //提示区
    TMessageBoxForm(Result).PanelCenter := TPanel.Create(Result);
    with TMessageBoxForm(Result).PanelCenter do
    begin
      Name := 'PanelCenter';
      Parent:= Result;
      Align:= alClient;
      BevelOuter:= bvNone;
      Color:= clWhite;
      Caption:= '';
    end;

    //主提示
    TMessageBoxForm(Result).Message := TLabel.Create(Result);
    with TMessageBoxForm(Result).Message do
    begin
      Name := 'Message';
      Parent := TMessageBoxForm(Result).PanelCenter;
      WordWrap := True;
      Caption := Msg;
      BoundsRect := TextRect;
      BiDiMode := Result.BiDiMode;
      SetBounds(lbLeft, lbMargin, TextRect.Right, TextRect.Bottom);
    end;

    if btnExit in Buttons then DefaultButton := btnExit else
      if btnCancel in Buttons then DefaultButton := btnCancel else
        if btnNo in Buttons then DefaultButton := btnNo else
          if btnOk in Buttons then DefaultButton := btnOk else
            DefaultButton := btnRetry;

    //按钮Left值
    X := ClientWidth - btnButtonWidth * ButtonCount - btnButtonSpace * (ButtonCount - 1) - 8;

    for B := Low(TNewMsgBoxBtn) to High(TNewMsgBoxBtn) do
    begin
      if B in Buttons then
      with TButton.Create(Result) do
      begin
        Name := ButtonNames[B];
        Parent := TMessageBoxForm(Result).PanelBottom;
        ParentFont:= False;
        Caption := ButtonCaptions[B];
        ModalResult := ModalResults[B];
        Default := False;
        TabStop := False;
        if (B = DefaultButton) or (ButtonCount = 1) then
        begin
          Default := True;
          TabStop := True;
        end;

        SetBounds(X, btnButtonMargin, btnButtonWidth, btnButtonHeight);
        Inc(X, btnButtonWidth + btnButtonSpace);
        if B = btnHelp then
          OnClick := TMessageBoxForm(Result).HelpButtonClick;
      end;
    end;
  end;
end;

{-------------------------------------------------------------------------------
  过程名:    MessageBoxPro
  功能:      自定义的消息框
  参数:      Msg: string;                  消息内容
             MsgTitle: string;             消息标题
             BoxType: TMsgBoxType;         消息显示图标
             Buttons: TNewMsgBoxBtns;      消息按钮集合
  返回值:    Integer
-------------------------------------------------------------------------------}
function MessageBoxPro(const Msg: string; BoxType: TMsgBoxType; Buttons: TNewMsgBoxBtns): Integer;
begin
  with CreateMessageBox(Msg, BoxType, Buttons) do
  try
    BorderIcons := BorderIcons - [biSystemMenu];
    Position := poScreenCenter;
    case BoxType of
      btSuccess    : MessageBeep(MB_ICONASTERISK);
      btWarning    : MessageBeep(MB_ICONEXCLAMATION);
      btError      : MessageBeep(MB_ICONERROR);
      btInformation: MessageBeep(MB_ICONASTERISK);
      btQuestion   : MessageBeep(MB_ICONQUESTION);
      btCustom     : MessageBeep(0);
    end;
    Result := ShowModal;
  finally
    Free;
  end;
end;

end.
